Shareware Grab Bag/Shareware Grab Bag.iso/095/tbbs105.arc/IO.INC

Text File | 1985-05-09 | 19KB | 741 lines

var
  cancelled : boolean;
  inbuffer  : line;

function charin(withecho: boolean):char; forward;

procedure sendout(ch: char);

{Character output - bypasses word-wrap; also performs
 "pause" and "abort" input character checks.}

  var temp: char;
      tctl: boolean;

  begin
    if not cancelled then begin
      if inready then begin
        temp := charin(noecho);
        if (temp = pause) or (upcase(temp) = 'S') then begin
          tctl := controls;
          controls := true;
          temp := charin(noecho);
          controls := tctl;
        end;
        if (temp = abort) or (upcase(temp) = 'C') then cancelled := true;
      end;
      xmitchar(ch);
      write(ch);
      if printon then write(lst, ch);
      if (ch = cr) and (lf = null) then writeln;
    end;
  end;

procedure flushbuff;

  var
    outpointer: byte;

  begin
    if length(buffer) > lastspace then
      for outpointer := lastspace + 1 to length(buffer) do
        sendout(buffer[outpointer]);
    lastspace := length(buffer);
  end;

procedure resetbuff;

  begin
    bufpointer := 0;
    lastspace := 0;
    charcount := 0;
    buffer := '';
  end;

procedure charout(ch:char);

{Character output using word-wrap}

  var
    buffull   : boolean;
    temp      : long;

  begin
    if caps then ch := upcase(ch);
    if not (ch in [null..#31]) then charcount := succ(charcount);
    if (ch = bs) and (charcount > 0) then charcount := charcount - 1;
    buffer := buffer + ch;
    bufpointer := length(buffer);
    buffull := (charcount + 2 > width);
    if buffull then begin
      if (lastspace > 0)
        then begin
          buffer := copy(buffer, lastspace + 1, bufpointer - lastspace);
          charcount := length(buffer);
          lastspace := 0;
          end {then}
        else begin
          flushbuff;
          resetbuff;
        end; {else}
      sendout(cr);
      sendout(lf);
    end; {if}
    if ch in [null..space] then flushbuff;
    if (ch=cr) then resetbuff;
  end;

procedure stringout(message:line);

  var
    charpos: integer;

  begin
    for charpos := 1 to length(message) do charout(message[charpos]);
  end;

procedure lineout; (* "forward" declared in MACHDEP *)

  begin
    stringout(message);
    charout(cr);
    charout(lf);
  end;

function timedin: boolean;

{returns false if no character received in within
 one second: used for XMODEM and input timeout.}

  var times: integer;

  begin
    times := 0;
    while (times < 500) and not inready do begin
      times := times + 1;
      delay(2);
    end;
    timedin := inready and cts;
  end;

function charin;

  var
    ch: char;
    countime: integer;

  begin
    ch := null;
    countime := 0;
    repeat
      if timedin then ch := recvchar else countime := countime + 1;
      if keypressed then read(kbd, ch);
      if countime > 300 then hangup;
      if not cts then ch := cr;
      if (ch <> bs) and not controls then ch := chr(ord(ch) and 127);
    until (ch in [abort, pause, bs, tab, cr, space..#127])
      or (controls and (ch <> null));
    if (ch = #127) and not controls then ch := bs;
    if ch = #$8D then ch := cr;
    if withecho then begin
      sendout(ch);
      if ch = bs then begin sendout(' '); sendout(bs); end;
    end;
    charin := ch;
  end;

procedure flush;

  var
    junk: char;

  begin
    while inready do junk := charin(noecho);
    clearstatus;
  end;

function inputstring(withecho: boolean): line;

  var
    temp:    line;
    ch:      char;

  begin
    temp := '';
    flush;
    repeat
      ch := charin(noecho);
      if (ch = bs) then begin
        if length(temp) > 0 then begin
          temp := copy(temp, 1, length(temp) - 1);
          if withecho then begin
            sendout(bs);
            sendout(space);
            sendout(bs);
          end;
        end;
      end
      else begin
        if (ch <> cr) and (length(temp) < 80)
        and ((ch in [tab, space..#126]) or controls) then begin
          if ch = tab then repeat
            temp := temp + space;
            if withecho then sendout(space);
          until (length(temp) mod 8) = 0
          else begin
            temp := temp + ch;
            if withecho then sendout(ch);
          end; {else}
        end
        else if (ch <> cr) then sendout(bell);
      end;
    until (ch = cr);
    charout(cr); charout(lf);
    inputstring := temp;
  end;

function getinput(prompt:line; maxlength:integer; withecho:boolean):line;

  var posn: integer;
      temp: char;

  begin
    if cancelled then begin
      cancelled := false;
      lineout(space);
    end;
    if inbuffer = '' then begin
      repeat
        cancelled := false;
        stringout(prompt);
        if bl = bell then stringout(bl);
      until cancelled = false;
      inbuffer := inputstring(withecho);
    end;
    if maxlength = 1 then begin
      if inbuffer = '' then temp := cr else begin
        temp := inbuffer[1];
        inbuffer := copy(inbuffer, 2, length(inbuffer)-1);
        if (length(inbuffer) > 1) and (inbuffer[1] = ';')
          then inbuffer := copy(inbuffer, 2, length(inbuffer)-1);
      end; {else}
      getinput := temp;
    end
    else begin
      posn := pos(';', inbuffer);
      if posn = 0 then posn := length(inbuffer) + 1;
      if posn > maxlength then begin
        posn := maxlength + 1;
        inbuffer := copy(inbuffer, 1, maxlength);
      end;
      getinput := copy(inbuffer, 1, posn - 1);
      if posn >= length(inbuffer)
        then inbuffer := ''
        else inbuffer := copy(inbuffer, posn + 1, length(inbuffer) - posn);
    end;
  end;

function allcaps(letters: person): person;

  var
    loop: byte;
    temp: person;

  begin
    temp := '';
    for loop := 1 to length(letters) do
      temp := temp + upcase(letters[loop]);
    allcaps := temp;
  end;

procedure awaitcall;

  var
    junk: char;

  begin
    setbaud(fast);
    writeln(cr + lf + 'Waiting for call...');
    flush;
    repeat
      if keypressed then begin
        read(kbd, junk);
        local := junk = esc;
        if local then setlocal else exitchar := junk;
      end;
    until cts or (exitchar = abort);
    clrscr;
    if exitchar <> abort then begin
      if local then writeln('Local control.') else writeln('On line...');
      delay(400);
      flush;
      junk := charin(noecho);
      if badframe or (junk <> cr) then setbaud(slow);
    end;
  end;

procedure clearsc;

  begin
    stringout(cs);
    delay(500);   {allows time for slow terminal screen clears}
  end;

function getcap(prompt: line): char;

  begin
    getcap := upcase(getinput(prompt, 1, echo));
  end;

function getint(nmax, star: integer; prompt: line): integer;

  var temp, test: integer;
      outstr, userin: name;

  begin
    str(nmax:4, outstr);
    repeat
      temp := 0;
      userin := getinput(prompt, 4, echo);
      val(userin, temp, test);
      if (temp > nmax) then lineout('Number too large: ' + outstr + ' maximum.');
    until ((test = 0) and (temp >= 0) and (temp <= nmax))
     or (userin = '*') or (userin = '') or (userin = '?') or not cts;
     if userin = '?' then getint := -1
      else if userin = '*' then getint := star
       else if test = 0 then getint := temp
        else getint := 0;
  end;

{Real-time clock support starts here...
 these routines must remain, even if there's
 no clock! To kill clock support, simply set
 "clockin" in BBS.PAS to false.}

type monthname = string[3];
     monames  = array[1..12] of monthname;

const months: monames = ('Jan','Feb','Mar','Apr','May','Jun',
                         'Jul','Aug','Sep','Oct','Nov','Dec');

function time(month, date, hour, min, sec: byte): name;

{Returns 14-character string containing time and date}

  var
    temps,
    tempm,
    tempd,
    temph: string[2];

  begin
    if clockin then begin
      str(sec:2,temps);
      str(min:2,tempm);
      str(hour:2,temph);
      str(date:2,tempd);
      if sec < 10 then temps := '0' + temps[2];
      if min < 10 then tempm := '0' + tempm[2];
      if date < 10 then tempd := '0' + tempd[2];
      time := temph + ':' + tempm + ':' + temps + ' ' + months[month] + tempd;
    end
    else time := '';
  end;

procedure showtime;

  var
    message: name;

  begin
    if clockin then begin
      clock(month, date, hour, min, sec);
      message := time(month, date, hour, min, sec);
      lineout('Time is: ' + message);
    end;
  end;

procedure calcconnect(var usehour, usemin, usesec: integer);

  begin
    clock(month, date, hour, min, sec);
    usemin := 0;
    usehour := 0;
    usesec := sec - onsec;
    if usesec < 0 then begin
      usesec := usesec + 60;
      usemin := -1;
    end;
    usemin := min - onmin + usemin;
    if usemin < 0 then begin
      usemin := usemin + 60;
      usehour := -1;
    end;
    usehour := hour - onhour + usehour;
    if usehour < 0 then usehour := usehour + 24;
  end;

procedure connecttime;

  var
    message: name;

  begin
    if clockin then begin
      calcconnect(usehour, usemin, usesec);
      message := copy(time(1, 1, usehour, usemin, usesec), 1, 8);
      lineout('Connect time: ' + message);
    end;
  end;

procedure searchlib(infile: name; var result, libsects: integer);

{Library-file support adapted from DELIB.PAS
 by Bela Lubkin of Borland International.}

  var
    temp: name;
    dirlength, offset, firstsec, loop, chrpos: integer;

  begin
    firstsec := 0; libsects := 0;
    blockread(libfile, libbuff, 1);
    if libbuff[0] <> 0 then result := 1;
    loop := 1;
    while (result = 0) and (loop <= 11) do begin
      if libbuff[loop] <> 32 then result := 1;
      loop := loop + 1;
    end;
    result := result + libbuff[12] + libbuff[13];
    if result = 0 then begin
      dirlength := libbuff[14] + 256*libbuff[15];
      if dirlength = 0 then result := 1;
    end;
    if result = 0 then begin
      loop := 0;
      while (loop < 4*dirlength-1) and (result = 0) and (firstsec = 0) do begin
        loop := loop + 1;
        offset := 32*(loop mod 4);
        if offset = 0 then blockread(libfile, libbuff, 1);
        if libbuff[offset] <> 0 then result := 1
        else begin
          temp := '';
          for chrpos := 1 to 8 do
            if libbuff[offset + chrpos] <> 32 then
              temp := temp + chr(libbuff[offset + chrpos]);
          if libbuff[offset + 9] <> 32 then begin
            temp := temp + '.';
            for chrpos := 9 to 11 do
              if libbuff[offset + chrpos] <> 32 then
                temp := temp + chr(libbuff[offset + chrpos]);
          end;
          if cts and (infile = 'DIR') then lineout(temp);
          if infile = temp then begin
            firstsec := libbuff[offset+12] + 256*libbuff[offset+13];
            libsects := libbuff[offset+14] + 256*libbuff[offset+15];
            seek(libfile, firstsec);
          end;
        end;
      end;
      if infile = 'DIR' then result := 0;
    end;
  end;

procedure libassign(filename: longname; var result: integer);

  var
    infile: name;
    slash: integer;
    library: boolean;

  begin
    result := 0;
    slash := pos('/', filename);
    library := (slash > 0);
    if library then begin
      infile := copy(filename, slash + 1, length(filename) - slash);
      filename := copy(filename, 1, slash - 1);
      if pos('.', filename) = 0 then filename := filename + '.LBR';
    end;
    assign(libfile, filename);
    {$I-} reset(libfile) {$I+};
    result := IOresult;
    if result = 0 then
      if library then searchlib(infile, result, libsects)
      else libsects := filesize(libfile);
    libeof := (libsects = 0);
  end;

procedure libblockread(var fileblock: filbuffer);

  begin
    if libsects > 0 then blockread(libfile, fileblock, 1);
    libsects := libsects - 1;
    if libsects = 0 then libeof := true;
  end;

procedure typefile(fname: longname; nowrap: boolean);

{Inline unsqueezer adapted from USQ.PAS V1.3, which
 was written by Scott Loftesness, adapted for Turbo
 Pascal by Steve Freeman and made compatible with
 Non-Turbo Pascal squeezers by myself.- BM}

  const
    recognize  = $FF76;
    numvals    = 257;      { max tree size + 1 }
    speof      = 256;      { special end of file marker }
    dle: char  = #$90;

  type
    tree       = array [0..255,0..1] of integer;

  var
    in_ptr, result: integer;
    in_buff: filbuffer;
    dnode: tree;
    inchar, curin, filecksum, bpos, i, repct, numnodes: integer;
    c, lastchar: char;
    origfile: name;
    squeezed, eofin: boolean;

  function getc: integer;

    begin
      in_ptr := in_ptr + 1;
      if in_ptr > 127 then begin
        if libeof then eofin := true
        else begin
          libblockread(in_buff);
          in_ptr := 0;
        end;
      end;
      if eofin then getc := 26 else getc := in_buff[in_ptr];
    end;

  function getw: integer;

    var in1,in2: integer;

    begin
      in1 := getc; in2 := getc;
      getw := in1 + in2 shl 8;
    end;

  procedure initialize;

    var str: string[14];

    begin
      in_ptr := 127; squeezed := true;
      repct:=0;   bpos:=99;   origfile:='';   eofin:=false;
      i := getw;
      if (recognize <> i) then begin
        squeezed := false;
        in_ptr := -1;
      end
      else begin
        filecksum := getw;     { get checksum from chars 2 - 3 of file }
        repeat    { build original file name }
          inchar:=getc;
          if inchar <> 0
            then origfile := origfile + chr(inchar);
        until inchar = 0;
        lineout('Original file: ' + origfile);
        numnodes:=ord(getw); { get the number of nodes in this files tree }
        if (numnodes<0) or (numnodes>=numvals) then begin
          squeezed := false;
          in_ptr := -1;
        end;
      end;
      if squeezed then begin
        dnode[0,0]:= -(speof+1);
        dnode[0,1]:= -(speof+1);
        numnodes:=numnodes-1;
        for i:=0 to numnodes do begin
          dnode[i,0]:=getw;
          dnode[i,1]:=getw;
        end;
      end;
    end;

  function getuhuff: char;

    var i: integer;

    begin
      i:=0;
      repeat
        bpos:=bpos+1;
        if bpos>7 then begin
          curin := getc;
          bpos:=0;
        end
        else curin := curin shr 1;
        i := ord(dnode[i,ord(curin and $0001)]);
      until (i<0);
      i := -(i+1);
      if i=speof then begin
        eofin:=true;
        getuhuff:=chr(26);
      end
      else getuhuff:=chr(i);
    end;

  function getcr: char;

    var c: char;

    begin
      if squeezed then begin
        if (repct>0) then begin
          repct:=repct-1;
          getcr:=lastchar;
        end
        else begin
          c:=getuhuff;
          if c<>dle then begin
            getcr:=c;
            lastchar:=c;
          end
          else begin
            repct:=ord(getuhuff);
            if repct=0 then getcr:=dle
            else begin
              repct:=repct-2;
              getcr:=lastchar;
            end;
          end;
        end;
      end
      else getcr := chr(getc);
    end; {getcr}

  begin
    libassign(fname, result);
    if result <> 0 then lineout('Can''t find ' + fname + '!')
    else begin
      initialize;
      while cts and not(cancelled or eofin) do begin
        c:=getcr;
        if c = #26 then eofin := true else begin
          if nowrap then begin
            if c <> #$8D then begin { <-- Allows no-wrap using WordStar files}
              c := chr(ord(c) and 127);
              if (c <> lnfd) then charout(c);
              if c = cr then charout(lf);
            end;
          end else sendout(c);
        end;
      end;
      close(libfile);
    end;
    unload;
  end;

procedure outfile(fname: longname);

  begin
    typefile(fname, true);
  end;

function findid(caller: person): integer;

  var
    usernum: integer;
    index: integer;

  begin
    usernum := 0;
    index := 0;
    lineout('Searching userlist...');
    {$I-} reset(idfile) {$I+};
    if IOresult <> 0 then rewrite(idfile);
    while (usernum = 0) and not eof(idfile) do begin
      index := index + 1;
      read(idfile, idrec);
      if idrec.user = caller then usernum := index;
    end;
    findid := usernum;
  end;

procedure getcomments(maxline: integer);

  var
    comfile: file of line;
    linenum: integer;
    head, temp: line;

  begin
    str(maxline:1, temp);
    lineout('Enter comment: up to ' + temp + ' lines, enter empty line to quit.');
    lineout(space);
    linenum := 0;
    assign(comfile, 'COMMENTS.BBS');
    {$I-} reset(comfile) {$I+};
    if IOresult <> 0 then rewrite(comfile);
    seek(comfile, filesize(comfile));
    head := caller;
    if clockin then head := head + '  ' + timeon;
    repeat
      linenum := linenum + 1;
      str(linenum:2, temp);
      stringout(temp + ': ');
      temp := inputstring(echo);
      if temp <> '' then begin
        if linenum = 1 then write(comfile, head);
        write(comfile, temp);
      end;
    until (temp = '') or (linenum = maxline) or not cts;
    close(comfile);
  end;

function nextuser: integer;

  var temp: integer;

  begin
    stringout('Finding space for new user: ');
    temp := findid('***');
    if temp = 0 then nextuser := 1 + filesize(idfile) else nextuser := temp;
  end;

procedure savedefaults;

  begin
    if usernum = 0 then usernum := nextuser;
    with idrec do begin
      user := caller;
      if expert then exfl := 0 else exfl := 255;
      if clockin then lsto := timeon;
      lstm := nextmess-1;
      pass := password;
      clr := cs;
      acc := access;
      bsp := bs;
      lnf := lf;
      upc := caps;
      wid := width;
    end;
    seek(idfile, usernum - 1);
    write(idfile, idrec);
  end;

procedure disconnect;

  var
    ch: char;

  begin
    clearsc;
    if not expert then lineout('Answering question with other than "Y" or "N" returns to BBS:');
    ch := getcap('Do you want to leave comments to the Sysop (Y/N)? ');
    if ch = 'Y' then getcomments(15);
    if (ch = 'N') or (ch = 'Y') or not cts then begin
      connecttime;
      lineout('Thanks for calling, ' + caller);
      savedefaults;
      hangup;
    end;
  end;